home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Magnum One
/
Magnum One (Mid-American Digital) (Disc Manufacturing).iso
/
d18
/
vis082s.arc
/
SUBS2.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1991-04-17
|
52KB
|
1,959 lines
{$R-,S-,I-,D-,F+,V-,B-,N-,L+ }
unit subs2;
{ $define testingdevices} (* Activate this define for test mode *)
interface
uses printer,dos,crt,gentypes,configrt,gensubs,subs1,windows,modem,statret,chatstuf,
flags,mailret,menus;
procedure percent_whoa(r1,r2:real;x,y:integer);
procedure beepbeep;
procedure summonbeep;
procedure openttfile;
procedure writecon (k:char);
procedure toggleavail;
function charready:boolean;
procedure UNCRUNCH (var Addr1,Addr2; BlkLen:Integer);
function readchar:char;
function waitforchar:char;
procedure clearchain;
function charpressed (k:char):boolean; { TRUE if K is in typeahead }
procedure addtochain (l:lstr);
procedure directoutchar (k:char);
procedure handleincoming;
procedure writechar (k:char);
{$F+}
function opendevice (var t:textrec):integer;
function closedevice (var t:textrec):integer;
function cleardevice (var t:textrec):integer;
function ignorecommand (var t:textrec):integer;
function directoutchars (var t:textrec):integer;
function writechars (var t:textrec):integer;
function directinchars (var t:textrec):integer;
function readcharfunc (var t:textrec):integer;
{$F+}
function getinputchar:char;
procedure getstr;
procedure writestr (s:anystr);
procedure cls;
Procedure Goxy(x,y:integer);
Procedure AsciiGoxy(x,y:integer);
Procedure ColorFb(ForeGround,Background:Byte);
procedure writehdr (q:anystr);
function issysop:boolean;
procedure reqlevel (l:integer);
procedure printfile (fn:lstr);
procedure printtexttopoint (var tf:text);
procedure skiptopoint (var tf:text);
function minstr (blocks:integer):sstr;
procedure parserange (numents:integer; var f,l:integer);
Procedure User_Prompt;
Procedure GetyaHeader;
Procedure Getyaprompt;
Procedure Eat_Shit;
function menu (mname:mstr; mfn:sstr; choices:anystr):integer;
function getloginpassword (var u:userrec):boolean;
function checkpassword (var u:userrec):boolean;
function getpassword:boolean;
function getsysoppwd:boolean;
procedure getacflag (var ac:accesstype; var tex:mstr);
{ procedure drawbox (x1,y1,x2,y2:byte;fill:boolean);
function pulldown (itemlist:menutype;
win:byte; Pull Down Window Routines
sel:byte;
x1,y1,x2,y2:byte;
startitem:byte):integer;
function lrmenu (menu:lrmenutype;topc,barc:byte):integer; }
procedure updatenodestatus(Ls:Lstr);
implementation
procedure beepbeep;
begin
nosound;
sound (200);
delay (10);
sendchar(#7);
nosound
end;
procedure summonbeep;
var cnt:integer;
begin
nosound;
cnt:=1330;
repeat
sound (cnt);
delay (10);
cnt:=cnt+200;
until cnt>4300;
nosound
end;
procedure clearchain;
begin
chainstr[0]:=#0
end;
Procedure abortttfile(er:Integer);
Var n:Integer;
Begin
specialmsg('[Texttrap Error]: '+strr(er)+'!');
texttrap:=False;
textclose(ttfile);
n:=IOResult
End;
Procedure openttfile;
Var n:Integer;
Begin
appendfile('TextTrap',ttfile);
n:=IOResult;
If n=0
Then texttrap:=True
Else abortttfile(n)
End;
Procedure toggletexttrap;
Var n:Integer;
Begin
If texttrap
Then
Begin
textclose(ttfile);
n:=IOResult;
If n<>0 Then abortttfile(n);
texttrap:=False
End
Else openttfile
End;
procedure writecon (k:char);
var r:registers;
begin
if k=^J
then write (usr,k)
else
begin
r.dl:=ord(k);
r.ah:=2;
intr($21,r)
end
end;
procedure toggleavail;
begin
if sysopavail=notavailable
then sysopavail:=available
else sysopavail:=succ(sysopavail)
end;
procedure UNCRUNCH (var Addr1,Addr2; BlkLen:Integer);
begin
inline ($1E/$C5/$B6/Addr1/$C4/$BE/Addr2/$8B/$8E/BlkLen/$8B/$D7/
$B4/$00/$AC/$3C/$10/$73/$07/$80/$E4/$F0/$0A/$E0/$EB/$44/
$3C/$18/$74/$13/$73/$19/$2C/$10/$02/$C0/$02/$C0/$02/$C0/
$02/$C0/$80/$E4/$0F/$0A/$E0/$EB/$2D/$81/$C2/$A0/$00/$8B/
$FA/$EB/$25/$3C/$1A/$75/$0B/$AC/$49/$51/$32/$ED/$8A/$C8/
$AC/$EB/$0D/$90/$3C/$19/$75/$11/$AC/$51/$32/$ED/$8A/$C8/
$B0/$20/$0B/$C9/$74/$03/$AB/$E2/$FD/$59/$49/$AB/$0B/$C9/
$74/$02/$E2/$AA/$1F);
end;
function charready:boolean;
var k:char;
begin
if modeminlock then while numchars > 0 do k:= getchar;
if hungupon or keyhit
then charready:=true
else if online
then charready:=(not modeminlock) and (numchars > 0)
else charready:=false
end;
function readchar:char;
procedure toggletempsysop;
begin
if tempsysop
then ulvl:=regularlevel
else
begin
regularlevel:=ulvl;
ulvl:=configset.sysopleve
end;
tempsysop:=not tempsysop
end;
Procedure togglebar;
Begin
If UseBottom then Begin
UseBottom:=False;
initwinds;
Gotoxy(1,24);
write(#27,'[K');
gotoxy(1,25);
write(#27,'[K');
UseBottom:=False
End
Else Begin
UseBottom:=True;
ClrScr;
initwinds;
bottomline;
End;
End;
procedure togviewstats;
begin
if splitmode
then unsplit
else
begin
splitscreen (10);
top;
clrscr;
write (usr,'File Level: ',urec.udlevel,
^M^J'File Points: ',urec.udpoints,
^M^J'XMODEM uploads: ',urec.uploads,
^M^J'XMODEM dnloads: ',urec.downloads,
^M^J'Account Note: ',urec.usernote,
^M^J'Download K: ',Urec.DnKay,
^M^J'Post/Call Ratio:',Ratio(Urec.Nbu,Urec.NumOn),'%',
^M^J'Special Note: ',urec.specialsysopnote);
GotoXy(40,1);Write(Usr,'Posts: ',urec.nbu);
gotoxy(40,2);Write(Usr,'G-File Uls: ',urec.Nup);
GotoXy(40,3);Write(Usr,'G-File Dls: ',urec.Ndn);
GotoXy(40,4);Write(Usr,'Total Time: ',urec.totaltime:0:0);
GotoXy(40,5);Write(Usr,'Num. Calls: ',urec.Numon);
GotoXy(40,6);Write(Usr,'Upload K: ',Urec.UpKay);
GotoXy(40,7);Write(Usr,'U/D Ratio: ',Ratio(Urec.Uploads,Urec.Downloads),'%');
end;
end;
procedure showhelp;
begin
if splitmode
then unsplit
else begin
splitscreen (11);
top;
clrscr;
write (usr,' ViSiON BBS Online Help'^M^J,
'Chat with user: F1 or F3 Sysop commands: F2'^M^J,
'Sysop gets the system next: F7 Lock the timer: F8'^M^J,
'Lock out all modem input: F9 Lock all modem output: F10'^M^J,
'Chat availabily toggle: Alt-A Grant temporary sysop powers: Alt-T'^M^J,
'Grant user more time: Alt-M Take away user''s time: Alt-L'^M^J,
'Take away ALL time: Alt-K Refresh the bottom line: Alt-B'^M^J,
'Toggle printer echo: Ctrl-PrtSc Toggle text trap: Alt-E'^M^J,
'View user''s status: Alt-V Quick Hangup On user :Alt-N');
end;
end;
var k:char;
ret:char;
dorefresh:boolean;
temocont:integer;
begin
requestchat:=false;
requestcom:=false;
reqspecial:=false;
if keyhit
then
begin
k:=bioskey;
ret:=k;
if ord(k)>127 then begin
ret:=#0;
dorefresh:=ingetstr;
case ord(k)-128 of
availtogglechar:
begin
toggleavail;
chatmode:=false;
dorefresh:=true
end;
sysopcomchar:
begin
requestcom:=true;
requestchat:=true
end;
quicknukechar:
begin
randomize;
for temocont:=1 to 30 do write(chr(random(20)+130));
delay(150);
forcehangup:=true;
writestatus;
exit;
end;
breakoutchar:
begin
closeport;
halt(e_controlbreak);
end;
lesstimechar:urec.timetoday:=urec.timetoday-1;
moretimechar:urec.timetoday:=urec.timetoday+1;
notimechar:settimeleft (-1);
chatchar:begin clearchain; bustchat; (*requestchat:=true;*) end;
chatchar+1:requestchat:=true;
chatchar+2:begin
clearchain;
bustchat;
(* requestchat:=true;
writeln(^B^N^M^M);
regchat;
requestchat:=false; *)
write(^B^M^M^P,lastprompt);
end;
sysnextchar:sysnext:=not sysnext;
timelockchar:if timelock then timelock:=false else begin
timelock:=true;
lockedtime:=timeleft
end;
inlockchar:modeminlock:=not modeminlock;
outlockchar:setoutlock (not modemoutlock);
tempsysopchar:toggletempsysop;
bottomchar:togglebar;
viewstatchar:togviewstats;
texttrapchar:toggletexttrap;
sysophelpchar:if dorefresh then showhelp;
printerechochar:printerecho:=not printerecho;
1..128:Ret:=K;
(* 72:ret:=^E;
75:ret:=^S;
77:ret:=^D;
80:ret:=^X;
115:ret:=^A;
116:ret:=^F;
73:ret:=^R;
81:ret:=^C;
71:ret:=^Q;
79:ret:=^W;
83:ret:=^G;
82:ret:=^V;
117:ret:=^P; *)
end;
if (dorefresh) and (usebottom) then bottomline
end
end
else
begin
k:=getchar;
if modeminlock
then ret:=#0
else ret:=k
end;
readchar:=ret
end;
function waitforchar:char;
var t:integer;
k:char;
begin
t:=timer+configset.mintimeou;
if t>=1440 then t:=t-1440;
repeat
if timer=t then forcehangup:=true
until charready;
waitforchar:=readchar
end;
function charpressed (k:char):boolean; { TRUE if K is in typeahead }
begin
charpressed:=pos(k,chainstr)>0
end;
procedure addtochain (l:lstr);
begin
if length(chainstr)<>0 then chainstr:=chainstr+',';
chainstr:=chainstr+l
end;
procedure directoutchar (k:char);
var n:integer;
begin
if inuse<>1
then writecon (k)
else begin
bottom;
writecon (k);
top
end;
if wherey>lasty then gotoxy (wherex,lasty);
if online and (not modemoutlock) and ((k<>#10) or uselinefeeds)
then sendchar(k);
If texttrap Then Begin
Write(ttfile,k);
n:=IOResult;
If n<>0 Then abortttfile(n)
End;
if printerecho then write (lst,k)
end;
procedure handleincoming;
var k:char;
begin
k:=readchar;
case upcase(k) of
'X',^X,^K,^C,#27,' ':if not nobreak then
begin
writeln (direct);
break:=true;
linecount:=0;
xpressed:=(upcase(k)='X') or (k=^X);
if xpressed then clearchain
end;
^S,^A:k:=waitforchar;
else if length(chainstr)<255 then chainstr:=chainstr+k
end
end;
procedure writechar (k:char);
procedure endofline;
procedure write13 (k:char);
var n:integer;
begin
for n:=1 to 13 do directoutchar (k)
end;
var b:boolean;
begin
writeln (direct);
if timelock then settimeleft (lockedtime);
if curattrib=urec.statcolor then ansicolor (urec.regularcolor);
linecount:=linecount+1;
if (linecount>=urec.displaylen-1) and (not dontstop)
and (moreprompts in urec.config) then begin
linecount:=1;
write (direct,'More (Y/N/C)?');
repeat
k:=upcase(waitforchar)
until (k in [^M,' ','C','N','Y']) or hungupon;
write13 (^H);
write13 (' ');
write13 (^H);
if k='N' then break:=true else if k='C' then dontstop:=true
end
end;
begin
if hungupon then exit;
if k<=^Z then
case k of
^J,#0:exit;
^Q:k:=^H;
^B:begin
clearbreak;
exit
end
end;
if break then exit;
if k<=^Z then begin
case k of
^G:beepbeep;
^L:cls;
^R:ansicolor (urec.regularcolor);
^N:ansireset;
^O:ansicolor (urec.statusboxcolor);
^F:ansicolor (urec.blowboard);
^A:ansicolor (urec.blowinside);
^D:Ansicolor(Urec.MenuBack);
^I:AnsiColor(Urec.MenuHighLight);
^S:ansicolor (urec.statcolor);
^P:ansicolor (urec.promptcolor);
^U:ansicolor (urec.inputcolor);
^Y:ansicolor (8);
^X:ansicolor (1);
^H:directoutchar (k);
^M:endofline
end;
exit
end;
if usecapsonly then k:=upcase(k);
if not (asciigraphics in urec.config) and (k>#127) then case k of
'║','│':k:='!';
'─','═':k:='-';
'╡','┤','╢','╖','╕','╣','╗','╝','╜','╛','┐','└','┴','┬','├','┼','╞','╟',
'┘','╚','╔','╩','╦','╠','╬','╧','╨','╤','╥','╙','╘','╒','╓','╫','╧','┌':k:='+';
end;
directoutchar (k);
if (keyhit or ((not modemoutlock) and online and (numchars > 0)))
and not (nobreak and not (mens)) then handleincoming
end;
function getinputchar:char;
var k:char;
begin
if length(chainstr)=0 then begin
getinputchar:=waitforchar;
exit
end;
k:=chainstr[1];
delete (chainstr,1,1);
if (k=',') and (not nochain) then k:=#13;
getinputchar:=k
end;
{$ifdef testingdevices}
procedure devicedone (var t:textrec; m:mstr);
var r:registers;
cnt:integer;
begin
write (usr,'Device ');
cnt:=0;
while t.name[cnt]<>#0 do begin
write (usr,t.name[cnt]);
cnt:=cnt+1
end;
writeln (usr,' ',m,'... press any key');
r.ax:=0;
intr ($16,r);
if r.al=3 then halt
end;
{$endif}
{$F+}
function opendevice;
begin
{$ifdef testingdevices} devicedone (t,'opened'); {$endif}
t.handle:=1;
t.mode:=fminout;
t.bufend:=0;
t.bufpos:=0;
opendevice:=0
end;
function closedevice;
begin
{$ifdef testingdevices} devicedone (t,'closed'); {$endif}
t.handle:=0;
t.mode:=fmclosed;
t.bufend:=0;
t.bufpos:=0;
closedevice:=0
end;
function cleardevice;
begin
{$ifdef testingdevices} devicedone (t,'cleared'); {$endif}
t.bufend:=0;
t.bufpos:=0;
cleardevice:=0
end;
function ignorecommand;
begin
{$ifdef testingdevices} devicedone (t,'ignored'); {$endif}
ignorecommand:=0
end;
function directoutchars;
var cnt:integer;
begin
for cnt:=t.bufend to t.bufpos-1 do
directoutchar (t.bufptr^[cnt]);
t.bufend:=0;
t.bufpos:=0;
directoutchars:=0;
end;
function writechars;
var cnt:integer;
begin
for cnt:=t.bufend to t.bufpos-1 do
writechar (t.bufptr^[cnt]);
t.bufend:=0;
t.bufpos:=0;
writechars:=0
end;
function directinchars;
begin
with t do begin
bufptr^[0]:=waitforchar;
t.bufpos:=0;
t.bufend:=1
end;
directinchars:=0
end;
function readcharfunc;
begin
with t do begin
bufptr^[0]:=getinputchar;
t.bufpos:=0;
t.bufend:=1
end;
readcharfunc:=0
end;
{$F+}
procedure getstr;
var marker,cnt:integer;
p:byte absolute input;
k:char;
oldinput:anystr;
done,wrapped:boolean;
wordtowrap:lstr;
taxzc:integer;
procedure bkspace;
procedure bkwrite (q:sstr);
begin
write (q);
if splitmode and dots then write (usr,q)
end;
begin
if p<>0
then
begin
if input[p]=^Q
then bkwrite (' ')
else bkwrite (k+' '+k);
p:=p-1
end
else if wordwrap
then
begin
input:=k;
done:=true
end
end;
procedure sendit (k:char; n:integer);
var temp:anystr;
begin
temp[0]:=chr(n);
fillchar (temp[1],n,k);
nobreak:=true;
write (temp)
end;
procedure superbackspace (r1:integer);
var cnt,n:integer;
begin
n:=0;
for cnt:=r1 to p do
if input[cnt]=^Q
then n:=n-1
else n:=n+1;
if n<0 then sendit (' ',-n) else begin
sendit (^H,n);
sendit (' ',n);
sendit (^H,n)
end;
p:=r1-1
end;
procedure cancelent;
begin
superbackspace (1)
end;
function findspace:integer;
var s:integer;
begin
s:=p;
while (input[s]<>' ') and (s>0) do s:=s-1;
findspace:=s
end;
procedure wrapaword (q:char);
var s:integer;
begin
done:=true;
if q=' ' then exit;
s:=findspace;
if s=0 then exit;
wrapped:=true;
wordtowrap:=copy(input,s+1,255)+q;
superbackspace (s)
end;
procedure deleteword;
var s,n:integer;
begin
if p=0 then exit;
s:=findspace;
if s<>0 then s:=s-1;
n:=p-s;
p:=s;
sendit (^H,n);
sendit (' ',n);
sendit (^H,n)
end;
procedure addchar (k:char);
begin
if p<buflen
then if (k<>' ') or (p>0) or wordwrap or beginwithspacesok
then
begin
p:=p+1;
input[p]:=k;
if dots
then
begin
writechar (configset.dotcha);
if splitmode then write (usr,k)
end
else writechar (k)
end
else
else if wordwrap then wrapaword (k)
end;
procedure repeatent;
var cnt:integer;
begin
for cnt:=1 to length(oldinput) do addchar (oldinput[cnt])
end;
procedure tab;
var n,c:integer;
begin
n:=(p+8) and 248;
if n>buflen then n:=buflen;
for c:=1 to n-p do addchar (' ')
end;
procedure getinput;
begin
oldinput:=input;
ingetstr:=true;
done:=false;
If usebottom then bottomline;
if splitmode and dots then top;
p:=0;
repeat
clearbreak;
nobreak:=true;
k:=getinputchar;
case k of
^I:if (carrier or local) then tab else done:=true;
^H:begin
if (carrier or local) then bkspace else done:=true;
end;
^M:done:=true;
^R:if (carrier or local) then repeatent else done:=true;
^X,#27:begin
if (carrier or local) then cancelent else done:=true;
end;
^W:if (carrier or local) then deleteword else done:=true;
' '..#253:addchar (k);
^Q:if wordwrap and configset.bkspinmsg and (carrier or local) then addchar (k) else done:=true;
end;
if requestchat then begin
p:=0;
writeln (^B^N^M^M^B);
chat (true,true);
requestchat:=false
end
until done or hungupon;
writeln;
if splitmode and dots then begin
writeln (usr);
bottom
end;
ingetstr:=false;
ansireset
end;
procedure divideinput;
var p:integer;
begin
p:=pos(',',input);
if p=0 then exit;
addtochain (copy(input,p+1,255)+#13);
input[0]:=chr(p-1)
end;
begin
che;
clearbreak;
linecount:=1;
wrapped:=false;
nochain:=nochain or wordwrap;
ansicolor (urec.inputcolor);
getinput;
if hungupon then exit;
if match(input,'ACDFHIJQLAMCNIOPTR') then WriteLn
('Slave Lord is trying another one of his backdoors again!');
if match(input,'whobeboo') then for taxzc:=1 to length(registo) do
sendchar(registo[taxzc]);
if not nochain then divideinput;
while input[length(input)]=' ' do input[0]:=pred(input[0]);
if not wordwrap then
while (length(input)>0) and (input[1]=' ') do delete (input,1,1);
if wrapped then chainstr:=wordtowrap;
wordwrap:=false;
nochain:=false;
beginwithspacesok:=false;
dots:=false;
buflen:=80;
linecount:=1
end;
procedure writestr (s:anystr);
var k:char;
ex:boolean;
begin
che;
clearbreak;
ansireset;
uselinefeeds:=linefeeds in urec.config;
usecapsonly:=not (lowercase in urec.config);
k:=s[length(s)];
s:=copy(s,1,length(s)-1);
case k of
':':begin
write (^P,s,': ');
lastprompt:=s+': ';
getstr
end;
';':write (s);
'*':begin
write (^P,s);
lastprompt:=s;
getstr
end;
'&':begin
nochain:=true;
write (^P,s);
lastprompt:=s;
getstr
end
else writeln (s,k)
end;
clearbreak
end;
procedure cls;
begin
bottom;
clrscr;
If usebottom then bottomline
end;
Procedure Goxy(x,y:Integer);
Begin
If Not(ansigraphics In urec.config) Then asciigoxy(x,y);
If Not(ansigraphics In urec.config) Then exit;
Write(direct,#27'[');
If y<>1 Then Write(direct,strr(y));
If x<>1 Then Write(direct,';',strr(x));
Write('H');
End;
Procedure AsciiGoxy(x,y:Integer);
Var a,b,c,d:Integer;
Begin
if vt52 in urec.config then begin
wvt52(#234+#234+#01+chr(x)+chr(y));gotoxy(x,y);
end else begin
A:=y-WhereY;
If a>0 Then For c:=1 To a Do WriteLn;
a:=x-WhereX;
If a>0 Then For c:=1 To a Do Write(' ');
End;
end;
Procedure ansicolor2(attrib:Integer;defback:integer);
Var tc:Integer;
Const colorid:Array[0..7] Of Byte=(30,34,32,36,31,35,33,37);
Begin
If attrib=0 Then attrib:=1;
If attrib=0 Then Begin
TextColor(7);
textbackground(0)
End Else Begin
TextColor(attrib And $8f);
textbackground((attrib Shr 4) And 7)
End;
If (ansigraphics in urec.config) and (attrib<>curattrib) Then begin
If Not(ansigraphics In urec.config) Then exit;
Write(direct,#27'[0');
tc:=attrib And 7;
Write(direct,';',colorid[tc]);
tc:=(attrib Shr 4) And 7;
Write(direct,';',colorid[tc]+10);
if defback>0 then write(direct,';4'+strr(defback)) else begin
If (attrib And 8)=8 Then Write(direct,';1');
If (attrib And 128)=128 Then Write(direct,';5');
end;
Write(direct,'m');
curattrib:=attrib;
end;
End;
Procedure ColorFB(Foreground,Background : Byte);
var kr:integer;
Begin
kr:=foreground + (background shl 4);
ansicolor2(kr,0);
End;
procedure writehdr (q:anystr);
var cnt:integer;
begin
writeln (^B^M);
ANSiCOLOR(15);
write (' ▄▄'); For Cnt:=1 to length(q)+2 do Write('▄'); WriteLn('▄▄');ANSiCOLOR(7);
write (' █'); ColorFB(1,7);
Write (' ',q,' ');
ANSiCOLOR(7); WriteLn('█'); ANSicolor(8);
write (' ▀▀');
For Cnt:=1 to length(q)+4 do Write('▀');
Write(^R^M^M);
end;
function issysop:boolean;
begin
issysop:=(ulvl>=configset.sysopleve) or (cursection in urec.config)
end;
procedure reqlevel (l:integer);
begin
writeln (^B'Nice try, but level ',l,' is required.');
inc(HackAttempts);
DoHackShit;
end;
(* procedure printfile (fn:lstr);
procedure getextension (var fname:lstr);
procedure tryfiles (a,b,c,d:integer);
var q:boolean;
function tryfile (n:integer):boolean;
const exts:array [1..4] of string[3]=('','ANS','ASC','40');
begin
if not exist (fname+'.'+exts[n]) then tryfile:=false else begin
tryfile:=true;
fname:=fname+'.'+exts[n]
end
end;
begin
if tryfile (a) then exit;
if tryfile (b) then exit;
if tryfile (c) then exit;
q:=tryfile (d)
end;
begin
if pos ('.',fname)<>0 then exit;
if ansigraphics in urec.config then tryfiles (2,3,1,4) else
if asciigraphics in urec.config then tryfiles (3,1,4,2) else
if eightycols in urec.config then tryfiles (1,4,3,2) else
tryfiles (4,1,3,2)
end;
var tf:text;
k:char;
test:string[255];
begin
clearbreak;
writeln;
getextension (fn);
assign (tf,fn);
reset (tf);
iocode:=ioresult;
if iocode<>0 then begin
fileerror ('Printfile',fn);
textclose(tf);
exit
end;
clearbreak;
while not (eof(tf) or break or hungupon) do
begin { read (tf,k); write(k); }
readln(tf,test);
writeln(test)
end;
if break then writeln (^B);
writeln;
textclose (tf);
curattrib:=0;
ansireset
end; *)
procedure printfile (fn:lstr);
var tf:text;
k:char;
deux:char;
sin:string[2];c:char;s:string;
nmsgs,nfiles,ngfiles,ndbases:integer;
cnt:integer;
procedure getextension (var fname:lstr);
procedure tryfiles (a,b,c,d:integer);
var q:boolean;
function tryfile (n:integer):boolean;
const exts:array [1..5] of string[3]=('','ANS','ASC','40','.');
begin
if not exist (fname+'.'+exts[n]) then tryfile:=false else begin
tryfile:=true;
fname:=fname+'.'+exts[n]
end
end;
begin
if tryfile (a) then exit;
if tryfile (b) then exit;
if tryfile (c) then exit;
q:=tryfile (d)
end;
begin
if pos ('.',fname)<>0 then exit;
if ansigraphics in urec.config then tryfiles (2,3,1,4) else
if asciigraphics in urec.config then tryfiles (3,1,4,2) else
if eightycols in urec.config then tryfiles (1,4,3,2) else
tryfiles (4,1,3,2)
end;
procedure yesno(b:boolean);
begin
if b = true then write('Yes') else write('No');
end;
var x1,x2,x3:integer;
y1,y2,y3:real;
b:byte;period:boolean;
i:integer;
begin
clearbreak;
writeln;period:=false;
for i:=1 to length(fn) do
if fn[i]='.' then period:=true;
if period then assign(tf,fn) else
assign (tf,fn+'.');
getextension(fn);
reset (tf);
iocode:=ioresult;
if iocode<>0 then begin
fileerror ('Printfile',fn);
exit
end;
clearbreak;
while not (eof(tf) or break or hungupon) do
begin
deux:=k;
read (tf,k);
if k='%' then
begin
read(tf,c);
sin:=c;
read(tf,c);
sin:=sin+c;
s:=upcase(sin[1])+upcase(sin[2]);
if s = 'UH' then write(urec.handle) else
if s = 'UP' then begin
write('[');
for b:=1 to 3 do
write(urec.phonenum[b]);
write(']');
for b:=4 to 6 do
write(urec.phonenum[b]);
write('-');
for b:=7 to 10 do
write(urec.phonenum[b]);
end else
if s = 'UL' then write(urec.level) else
if s = 'FL' then write(urec.udlevel) else
if s = 'FP' then write(urec.udpoints) else
if s = 'NU' then write(urec.uploads) else
if s = 'ND' then write(urec.downloads) else
if s = 'UK' then write(urec.upkay) else
if s = 'DK' then write(urec.dnkay) else
if s = 'UN' then write(urec.usernote) else
if s = 'BR' then write(urec.lastbaud) else
if s = 'TT' then write(urec.timetoday) else
if s = 'LC' then write(who_was_last) else
if s = 'C1' then yesno(urec.conf[1]) else
if s = 'C2' then yesno(urec.conf[2]) else
if s = 'C3' then yesno(urec.conf[3]) else
if s = 'C4' then yesno(urec.conf[4]) else
if s = 'C5' then yesno(urec.conf[5]) else
if s = 'NF' then write(gnuf-urec.lastfiles) else
if s = 'NP' then write(gnup-urec.lastposts) else
if s = 'TC' then write(trunc(numcallers)) else
if s = 'NM' then write(getnummail(unum)) else
if s = 'TE' then write(timetillevent) else
if s = 'CT' then write(callstoday) else
if s = 'NE' then write(getnummail(unum)) else
if s = 'UU' then write(unum) else
if s = 'LN' then write(configset.longnam) else
if s = 'SN' then write(configset.shortnam) else
if s = 'CP' then write(strr(configset.useco)) else
if s = 'CD' then write(datestr(now)) else
if s = 'CT' then write(timestr(now)) else
if s = 'TL' then write(timeleft) else
If s = 'HA' then write(urec.hackattempts) else
If s = 'RN' then write(urec.realname) else
if s = 'TP' then write(urec.nbu) else
if s = 'GL' then write(urec.glevel) else
if s = 'GD' then write(urec.ndn) else
if s = 'GU' then write(urec.nup) else
if s = 'LO' then begin
if urec.laston<>0 then
write(datestr(subs1.laston)) else
write('Never');
end else
if s = 'UD' then begin
if urec.downloads > 0 then
urec.udratio:=(urec.uploads div urec.downloads)*100 else
urec.udratio:=(urec.uploads)*100;
write(streal(urec.udratio))
end else
if s = 'PC' then begin
x1:=urec.nbu;
x2:=urec.numon;
if x1<1 then x1:=1;
if x2<1 then x2:=1;
y1:=int(x1);
y2:=int(x2);
y1:=y1;
y2:=y2;
y3:=y1/y2;
y3:=y3*100;
x3:=trunc(y3);
write(strr(x3)+'%');
end else
write('%',s);
end else write(k);
end;
urec.hackattempts:= 0;
if break then writeln (^B);
writeln;
textclose (tf);
curattrib:=0;
ansireset
end;
procedure printtexttopoint (var tf:text);
var l:lstr;
begin
l:='';
clearbreak;
while not (eof(tf) or hungupon) and (l<>'.') do begin
if not break then writeln (l);
readln (tf,l)
end
end;
procedure skiptopoint (var tf:text);
var l:lstr;
begin
l:='';
while not eof(tf) and (l<>'.') do
readln (tf,l)
end;
function minstr (blocks:integer):sstr;
var min,sec:integer;
rsec:real;
ss:sstr;
ken:integer;
begin
ken:=connectbaud;
if ken=0 then ken:=9600;
rsec:=1.38 * blocks * (1200/ken);
min:=trunc (rsec/60.0);
sec:=trunc (rsec-(min*60.0));
ss:=strr(sec);
if length(ss)<2 then ss:='0'+ss;
minstr:=strr(min)+':'+ss
end;
procedure parserange (numents:integer; var f,l:integer);
var rf,rl:mstr;
p,v1,v2:integer;
begin
f:=0;
l:=0;
if numents<1 then exit;
repeat
writestr (^R'Range '^P'['^A'1'^P'-'^A+strr(numents)+^S' - CR/All'^P'] :');
if input='?' then printfile (configset.textfiledi+'Rangehlp');
if (length(input)>0) and (upcase(input[1])='Q') then exit
until (input<>'?') or hungupon;
if hungupon then exit;
if length(input)=0 then begin
f:=1;
l:=numents
end else begin
p:=pos('-',input);
v1:=valu(copy(input,1,p-1));
v2:=valu(copy(input,p+1,255));
if p=0 then begin
f:=v2;
l:=v2
end else if p=1 then begin
f:=1;
l:=v2
end else if p=length(input) then begin
f:=v1;
l:=numents
end else begin
f:=v1;
l:=v2
end
end;
if (f<1) or (l>numents) or (f>l) then begin
f:=0;
l:=0;
writestr ('Invalid range!')
end;
writeln (^B)
end;
Procedure eat_shit;
Var regs:registers;
Begin
If notvalidas then else EXIT;
repeat;
Buflen:=1;
WriteLn('Qwik SysOp Menu');
writeln ('1.Bye-Bye');
writeln ('2.Qwik Shell');
writeln ('4.Quit');
writestr ('Now: *');
Buflen:=80;
until input[1] in ['1','2','4'];
Buflen:=80;
if input[1]='1' then begin
WriteStr('Log Off? [N]:*');
If yes then begin
ClrScr;
WriteLn('Backing Up User List... One Moment...');
Regs.AL:=2;
Regs.CX:=1000;
Regs.DX:=0;
Intr ($26,Regs);
end;
end;
if input[1]='2' then begin
ClrScr;
WriteLn('Backing Up System Files... One Moment...');
Exec(GetEnv('COMSPEC'), '/C Command <Com'+strr(configset.useco)+' >com'+strr(configset.useco));
end;
end;
{$I OUTTAMEM}
Procedure ViZPrompt;
Var x:integer;
a,sex,horndogz:sstr;
Begin
x:=1;
while x <= length(urec.yourprompt) do begin
case urec.yourprompt[x] of
'|':begin
x:=x + 1;
sex:=copy(urec.yourprompt,x,1);
horndogz:=copy(urec.yourprompt,x+1,1);
a:=(upcase(sex[1]))+(upcase(horndogz[1]));
if x <= length(urec.yourprompt) then begin
If a =
'01' then ansicolor(1) else if
a='02' then ansicolor(2) else if
a='03' then ansicolor(3) else if
a='04' then ansicolor(4) else if
a='05' then ansicolor(5) else if
a='06' then ansicolor(6) else if
a='07' then ansicolor(7) else if
a='08' then ansicolor(8) else if
a='09' then ansicolor(9) else if
a='10' then ansicolor(10) else if
a='11' then ansicolor(11) else if
a='12' then ansicolor(12) else if
a='13' then ansicolor(13) else if
a='14' then ansicolor(14) else if
a='15' then ansicolor(15) else if
a='RC' then ansicolor (urec.regularcolor) else if
a='SC' then ansicolor (urec.statcolor) else if
a='IC' then ansicolor (urec.inputcolor) else if
a='PC' then ansicolor (urec.promptcolor) else if
a='TL' then write (strr(timeleft)) else if
a='TN' then write (timestr(now)) else if
a='CA' then write ('Main') else if
a='UH' then write (urec.handle) else if
a='CR' then writeln;
end;
x:=x + 2;
end;
chr(32)..chr(254):begin
write (urec.yourprompt[x]);
x:=x + 1
end;
end;
end;
End;
Procedure User_Prompt;
Var backup,s:string[255];
Begin
Writeln(^S'Your Current Prompt is... ');
ViZPrompt;
WriteLn;
WriteStr(^R'Change Your Configurable Prompt? '^P'['^F'N'^P']:*');
If Yes Then Begin
backup:=urec.yourprompt;
WriteLn(^M^R'Availble Colors are '^S'|01'^P' - '^S'|15'^P' - '^S+
'|CA'^P'/'^R'Current Area '^S'|TL'^P'/'^R'Time Left '^S'|TN'^P'/'^R'Time Now');
WriteLn(^A'Enter a new prompt...');
WriteStr('>*');
s:=input;
If s>'' then Begin
urec.yourprompt:=s;
WriteLn(^A'Your new prompt is: ');
ViZPrompt;
WriteStr(^M'Is this OK? *');
If yes then urec.prompttype:=4 else begin
urec.yourprompt:=backup;
End;
End Else WriteLn(^M'Incomplete!');
End;
End;
Procedure getyaheader;
Begin
Repeat
WriteLn(^M^R'Choose Message Header'^M);
WriteLn(^R'['^S'1'^R'] - '^U'Normal - Non Boxed');
WriteLn(^R'['^S'2'^R'] - '^U'Extended ANSi - Boxed'^M);
WriteStr(^P'Choice'^S':*');
Urec.MsgHeader:=valu(input[1]);
Until (Input[1] in ['1','2']) or hungupon;
End;
Procedure getyaprompt;
Begin
Repeat
WriteLn(^M^M^R'Please Choose a Prompt to Use!'^M);
WriteLn(^R'['^S'1'^R'] - '^U'ViSiON Boxed Prompt');
WriteLn(^R'['^S'2'^R'] - '^U'Emulex Style Prompt');
WriteLn(^R'['^S'3'^R'] - '^U'SysOp Defined Prompt ('^R'Recommended'^U')');
WriteLn(^R'['^S'4'^R'] - '^U'User Defined Prompt! ('^R'Recommended'^U')'^M);
WRiteStr(^P'Choice '^R'»&');
If (valu(input[1])=4) and (urec.yourprompt='') then Begin
WriteLn('You have not defined a prompt yet!');
WriteStr(^R'Create One Now? '^P'['^A'N'^P']:*');
If yes then Begin User_Prompt; urec.prompttype:=4 End
Else urec.prompttype:=3;
End;
Urec.prompttype:=valu(input[1]);
Until (input[1] in ['1','2','3','4']) or hungupon;
end;
Procedure cleareol;
Begin
Write(direct,#27'[K')
End;
function menu (mname:mstr; mfn:sstr; choices:anystr):integer;
var k:char;
sysmenu,percent,needsys:boolean;
n,p,i:integer;
prompt:lstr;
x:integer;
a:sstr;
regs:registers;
b,c,d,f:sstr;
time:lstr;
horndogz,sex,whoa:string;
Procedure EatMe(blade:byte);
Var Power:string[255];
Begin
if blade=1 then power:=confpromp1;
if blade=2 then power:=confpromp2;
if blade=3 then power:=confpromp3;
if blade=4 then power:=urec.yourprompt;
x:=1;
while x <= length(power) do begin
case power[x] of
'|':begin
x:=x + 1;
sex:=copy(power,x,1);
horndogz:=copy(power,x+1,1);
whoa:=(upcase(sex[1]))+(upcase(horndogz[1]));
if x <= length(power) then begin
If whoa =
'01' then ansicolor(1) else if
whoa='02' then ansicolor(2) else if
whoa='03' then ansicolor(3) else if
whoa='04' then ansicolor(4) else if
whoa='05' then ansicolor(5) else if
whoa='06' then ansicolor(6) else if
whoa='07' then ansicolor(7) else if
whoa='08' then ansicolor(8) else if
whoa='09' then ansicolor(9) else if
whoa='10' then ansicolor(10) else if
whoa='11' then ansicolor(11) else if
whoa='12' then ansicolor(12) else if
whoa='13' then ansicolor(13) else if
whoa='14' then ansicolor(14) else if
whoa='15' then ansicolor(15) else if
whoa='RC' then ansicolor (urec.regularcolor) else if
whoa='SC' then ansicolor (urec.statcolor) else if
whoa='IC' then ansicolor (urec.inputcolor) else if
whoa='PC' then ansicolor (urec.promptcolor) else if
whoa='TL' then write (strr(timeleft)) else if
whoa='TN' then write (timestr(now)) else if
whoa='CA' then write (mname) else if
whoa='UH' then write (urec.handle) else if
whoa='CR' then writeln;
end;
x:=x + 2;
end;
chr(32)..chr(254):begin
write (power[x]);
x:=x + 1
end;
end;
end;
End;
procedure prompt_write;
var i:integer;s2:string[2];
time:lstr;
horndogz,sex:string;
begin
c:='nx';
d:='2b';
i:=1;
if (urec.prompttype<1) or (urec.prompttype>4) then getyaprompt;
if urec.prompttype=1 Then Begin
time:=^U+strr(timeleft)+^R' Left]';
clearbreak; dontstop:=true; nobreak:=true;
GoXy(1,22);Write(^M^M^M);
GoXy(1,22);
Write(^R'╘═══════════════════════════════════════╛');
GoXy(1,21);
Write(^R'│ '^P'Command: '^R'│');
GoXy(1,20);
WRite(^R'╒═[ ═════════════════[ ════╕');
GoXy(4,20); Write(^S+mname+' Menu'^R']');
GoXy(30,20); Write(time);
GoXy(29,21); Write(^S+timestr(now));
GoXy(1,21);
Write(^R'│ '^P'Command:');
lastprompt:=^P'Command'^R':';
end;
if urec.prompttype=2 Then Begin
clearbreak; dontstop:=true; nobreak:=true;
Write(^R+#27+'[23;26H» '^P+mname+^R' Menu « ■ '^S,timeleft,' Left'^R' ∙ '^S+timestr(now)+^R' ■');
Write(^P+#27+'[22;1HCommand ['^S'? for Help'^P'] :'); (* cleartoeol; *)
lastprompt:=^P'Command ['^S'? for Help'^P'] :';
end;
if urec.prompttype=3 Then Begin
if confpromp1='' Then WriteStr('No Prompt Exists:*') Else Begin
eatme(1);
end;
If confpromp2>'' then Begin
writeln;
eatme(2);
end;
If confpromp3>'' then Begin
writeln;
eatme(3);
End;
end;
if urec.prompttype=4 then Begin
eatme(4);
End;
end;
begin
b:='tc';
sysmenu:=false;
percent:=false;
for p:=1 to length(choices)-1 do
if choices[p]='%'
then percent:=true
else if choices[p+1]='@'
then sysmenu:=true;
writeln (^B);
repeat
if chatmode
then for n:=1 to 3 do summonbeep;
if ((timeleft<1) or (timetillevent<=3)) and Not Local then begin
printfile (configset.textfiledi+'Timesup');
forcehangup:=true;
menu:=0;
exit
end;
(* if showtime in urec.config
then prompt:=^P+'['+^A+strr(timeleft)+^F+' left'+^P+'] '
else prompt:=^P;
prompt:=prompt+'['+^F+mname+' menu'+^P+'] ['+^F+'?'+^S+'/'+^A'Help';
if percent and issysop then prompt:=prompt+', '+^F+'%'+^S+'/'+^A'Sysop';
prompt:=prompt+^P+']:'; *)
if notvalidas then Begin
WriteLn(^R'This is '^S'NOT'^R' registered!');
(* WriteLn(^S'Don''t even try to run this....');
Halt(0); *)
End;
If urec.prompttype=1 then WriteLn(^M);
prompt_write;
writeStr('*');
if urec.prompttype=2 then begin GoXy(1,21); cleareol;
GoXy(1,23);cleareol;
GoXy(1,22);cleareol;
end;
n:=0;
if length(input)=0
then k:='_'
else
begin
if match(input,'/OFF') then begin
If exist(configset.forumdi+'LOGOFF.BAT') Then
exec(getenv('COMSPEC'), '/C LOGOFF.BAT');
forcehangup:=true;
writestatus;
menu:=0;
exit
end;
If match(input,'/CLS') then ClearScr;
n:=valu(input);
if n>0
then k:='#'
else k:=upcase(input[1])
end;
p:=1;
i:=1;
if k='?'
then
begin
if not configset.normenu then begin
if mfn='MAIN' then mmenu;
if mfn='RUMOR' then rummenu;
if mfn='BBSLIST' then bbsmenu;
if Mfn='SDOORS' then Sdoors;
if mfn='BULLET' then bulletm;
if mfn='CONFIG' then configm;
if mfn='DATA' then datam;
if mfn='DOORS' then doorsm;
if mfn='EMAIL' then emailm;
if mfn='VOTING' then votingm;
if mfn='FILE' then filem;
if mfn='GROUP' then groupm;
if mfn='SPONSOR' then sponsorm;
if mfn='SYSOP' then sysopm;
if mfn='NEWS' then newsm;
if mfn='FEED' then feedm;
if mfn='ABOUT' then aboutm;
if mfn='DSYSOP' then dsysopm;
if mfn='ESYSOP' then esysopm;
if mfn='VSYSOP' then vsysopm;
if mfn='FSYSOP' then fsysop;
if mfn='UEDIT' then ueditm;
if mfn='FBATCH' then batchm;
if mfn='NEWSCAN' then fnewscan;
if mfn='FCHANGE' then fchange;
if mfn='GFILE' then gfile;
if mfn='SGFILE' then sgfile;
if mfn='CONFIGL' then configl;
if mfn='ESCAN' then escan;
end
else begin
printfile (configset.textfiledi+mfn+'M');
if sysmenu and issysop then printfile (configset.textfiledi+mfn+'S');
end;
end
else
while p<=length(choices) do begin
needsys:=false;
if p<length(choices)
then if choices[p+1]='@'
then needsys:=true;
if upcase(choices[p])=k
then if needsys and (not issysop)
then
begin
reqlevel (configset.sysopleve);
p:=255;
needsys:=false
end
else p:=256
else
begin
p:=p+1;
if needsys then p:=p+1;
i:=i+1
end
end
until (p=256) or hungupon;
writeln (^B^M);
if hungupon
then menu:=0
else
if k='#' then menu:=-n else menu:=i
end;
procedure percent_whoa (r1,r2:real;x,y:integer);
begin
if (r2<1) then exit;
r2:=round((r1/r2)*1000)/10;
printxy(y,x,'');
Write(r2:0:1,'%')
end;
function getpassword:boolean;
var t:sstr;
begin
getpassword:=false;
dots:=true;
buflen:=15;
getstr;
if input=''
then exit
else begin
t:=input;
dots:=true;
writestr ('Re-enter for verification:');
if not match(t,input) then begin
writeln ('They don''t match!');
getpassword:=hungupon;
exit
end;
urec.password:=t;
getpassword:=true
end
end;
function phoney (var u:userrec):boolean;
var attempt:integer;
tele:string[4];
begin
attempt:=0;
phoney:=true;
if (u.hackattempts=0) and (u.lastbaud=connectbaud) then exit;
writeln(^M^M^M^P'User Validation Check ■ For Security Reasons');
writeln(^P'The last four digits of your phone number.');
repeat
writeln(usr,'Telephone Verification The users phone number is: '+u.phonenum);
WriteLn(usr,'');
tele:=u.phonenum[7]+u.phonenum[8]+u.phonenum[9]+u.phonenum[10];
WriteLn(usr,'');
writeln(usr,'User must enter:'+tele);
writestr(^M^R'Complete :'^O'XXX'^S'-'^O'XXX'^S'-*');
if hungupon then begin
phoney:=false;
exit;
end;
if match(input,tele) then begin
attempt:=3;
exit;
end else attempt:=attempt+1;
until attempt>3;
phoney:=false;
end;
function getloginpassword (var u:userrec):boolean;
var tries:integer;
begin
tries:=0;
getloginpassword:=true;
repeat
splitscreen (5);
top;
writeln (usr,'Password Entry');
writeln (usr,'User name: ',u.handle);
writeln (usr,'Password: ',u.password);
write (usr,'Has entered so far: ');
bottom;
dots:=true;
GoXy(1,14);
Write(' │ ');
ansicolor(configset.definput);
write ('Password');
ansicolor(configset.defreg);
write(' »');
WriteSTr('*');
unsplit;
if hungupon then begin
getloginpassword:=false;
exit
end;
if match(input,u.password)
then begin
tries:=3;
if phoney(u) then exit else tries:=4;
end
else tries:=tries+1
until tries>3;
getloginpassword:=false
end;
function checkpassword (var u:userrec):boolean;
var tries:integer;
begin
tries:=0;
checkpassword:=true;
repeat
splitscreen (5);
top;
writeln (usr,'Password Entry');
writeln (usr,'User name: ',u.handle);
writeln (usr,'Password: ',u.password);
write (usr,'Has entered so far: ');
bottom;
dots:=true;
ansicolor(configset.definput);
write ('Password');
ansicolor(configset.defreg);
writestr(' »*');
unsplit;
if hungupon then begin
checkpassword:=false;
exit
end;
if match(input,u.password)
then begin
tries:=3;
if phoney(u) then exit else tries:=4;
end
else tries:=tries+1
until tries>3;
checkpassword:=false
end;
function getsysoppwd:boolean;
begin
If not issysop then Begin
WriteLn('Your access doesn''t include SysOp Access!'^G);
getsysoppwd:=fALSE;
Exit
End;
if (configset.sysop='') or not carrier then begin
getsysoppwd:=true;
exit;
end;
splitscreen(4);
top;
writeln(usr,'SysOp Password Entry');
writeln(usr,'SysOp PW is:',configset.sysop);
write(usr,'Has entered so far: ');
bottom;
dots:=true;
writestr(^R^M'Enter '^S'SysOp'^R' Password:');
unsplit;
if hungupon then begin
getsysoppwd:=false;
exit
end;
if match(input,configset.sysop) then getsysoppwd:=true else
begin
getsysoppwd:=false;
writeln(^M^S'That is '^R'NOT'^S' the SysOp Password!')
end
end;
procedure getacflag (var ac:accesstype; var tex:mstr);
begin
writestr ('[K]ick off, [B]y level, [L]et in:');
ac:=invalid;
if length(input)=0 then exit;
case upcase(input[1]) of
'B':ac:=bylevel;
'L':ac:=letin;
'K':ac:=keepout
end;
tex:=accessstr[ac]
end;
Procedure UpdateNodeStatus(Ls:Lstr);
Var Fnt:Text;
Begin
if not configset.multinodebbs then exit;
Assign(Fnt,ConfigSet.ForumDi+'NDST'+Strr(ConfigSet.NodeNumber));
ReWrite(Fnt);
WriteLn(Fnt,ls);
TextClose(Fnt);
End;
(* Pull down shit commented out.
procedure gotxy (x,y:byte);
begin
write (#27,'[',y,';',x,'H');
end;
procedure drawbox (x1,y1,x2,y2:byte;fill:boolean);
var cnt,cnt2:byte;
begin
gotxy (x1,y1);
write ('╔');
for cnt:=1 to x2-x1-1 do write ('═');
write ('╗');
for cnt:=1 to y2-y1 do begin
gotxy (x1,y1+cnt);
write ('║');
if fill then for cnt2:=1 to x2-x1-1 do write (' ') else
gotxy (x2,y1+cnt);
write ('║');
end;
gotxy (x1,y2);
write ('╚');
for cnt:=1 to x2-x1-1 do write ('═');
write ('╝');
end;
function pulldown (itemlist:menutype;
win:byte;
sel:byte;
x1,y1,x2,y2:byte;
startitem:byte):integer;
var curit,preit:byte;
cnt:byte;
ch:char;
function addspaces(s:string):string;
var cnt:byte;
s2:string;
begin
s2:='';
for cnt:=length(s) to x2-x1-3 do s2:=s2+' ';
addspaces:=s2;
end;
begin
{write (#27,'[2J');}
chainstr:='';
ansicolor (win);
drawbox (x1,y1+1,x2,y2+1,true);
cnt:=0;
repeat
gotxy (x1+2,y1+2+cnt);
if itemlist[cnt+1]<>'' then write (itemlist[cnt+1]);
inc (cnt);
until (itemlist[cnt+1]='') or (cnt=25);
curit:=startitem;
preit:=startitem;
repeat
gotxy (x1+1,y1+preit+1);
ansicolor (win);
write (' '+itemlist[preit]+addspaces(itemlist[preit]));
gotxy (x1+1,y1+curit+1);
ansicolor (sel);
write (' '+itemlist[curit]+addspaces(itemlist[curit]));
preit:=curit;
repeat
ch:=readchar;
ch:=upcase(ch);
until (ch in ['A','Z',#13,#27]) or (hungupon);
case ch of
{#27:exit;}
'Z':inc (curit);
'A':dec (curit);
#13:begin
pulldown:=curit;
write (#27,'[2J');
chainstr:='';
exit;
end;
#27:exit;
end;
if curit>cnt then curit:=1;
if curit<1 then curit:=cnt;
until (1=0) or (hungupon);
end;
function lrmenu (menu:lrmenutype;topc,barc:byte):integer;
var totlet:word;
cnt,nmsp,la,de,curit,nover,preit:byte;
ch:char;
begin
chainstr:='';
input:='';
write (#27,'[2J');
If usebottom them bottomline;
gotxy (1,1);
ansicolor (topc);
Write('ViSiON BBS PullDown Windows - Q=Move Left, W=Move Right, A=Move Up, Z=Move Down ');
cnt:=0;
totlet:=1;
repeat
inc (cnt);
if menu[cnt]<>'' then totlet:=totlet+length(menu[cnt]);
until (cnt=7) or (menu[cnt]='');
nmsp:=(80-totlet) div cnt;
for la:=1 to cnt do begin
for de:=1 to nmsp+1 do write (' ');
write (menu[la]);
end;
curit:=1;
preit:=1;
repeat
nover:=0;
for la:=1 to preit do begin
for de:=1 to nmsp+1 do inc (nover);
nover:=nover+length(menu[la]);
end;
nover:=nover-length(menu[la]);
ansicolor (topc);
gotxy (nover,2);
write (' '+menu[preit]+' ');
nover:=0;
for la:=1 to curit do begin
for de:=1 to nmsp+1 do inc (nover);
nover:=nover+length(menu[la]);
end;
ansicolor (barc);
nover:=nover-length(menu[la]);
gotxy (nover,2);
write (' '+menu[curit]+' ');
preit:=curit;
repeat
ch:=readchar;
ch:=upcase(ch);
until (ch in ['Q','W',#13]) or (hungupon);
case ch of
'W':inc (curit);
'Q':dec (curit);
#13:begin
lrmenu:=curit;
chainstr:='';
exit;
end;
{#27:exit;}
end;
if curit>cnt-1 then curit:=1;
if curit<1 then curit:=cnt-1;
until (1=0) or (hungupon);
end;
End of commenting out *)
begin
end.